perm filename TRYNXT[C,JRA] blob
sn#017895 filedate 1972-12-27 generic text, type T, neo UTF8
00100
00200 (GLOBAL (FUNCTIONS TRY-NEXT
00300 NOTE
00400 ADIEU
00500 AU-REVOIR
00600 INSTANCE
00700 GET-POSSIBILITIES
00800 SET-POSSIBILITIES
00900 GENERATE)
01000 (RESERVED *IGNORE
01100 *ITEM
01200 *NOTE
01300 *METHOD
01400 *GENERATOR
01500 *AU-REVOIR
01600 *BLOCK
01700 *POSSIBILITIES))
01800
01900 (DECLARE (SYMBOLS T)
02000 (GENPREFIX \T)
02100 (GENSYM (QUOTE T))
02200 (SPECIAL TEM TEM1 TEM2 ALINK BVARS EXP CLINK FRAME* VAL)
02300 (*FEXPR CERR INSTANCE PROPOSE /,)
02400 (*LEXPR CSET MATCH VLOC VFRAME ACCESS CONTROL))
02500
02600 (DEFPROP ALINK (LAMBDA (L) (LIST (QUOTE CDADR) (CADR L))) MACRO)
02700
02800 (DEFPROP CLINK (LAMBDA (L) (LIST (QUOTE CDDDR) (CADR L))) MACRO)
02900
03000 (CDEFUN TRY-NEXT
03100 (POSSIBILITIES "OPTIONAL" (NOMORE NIL) (MESSAGE NIL))
03200 "AUX"
03300 (POS)
03400 (: TRY-NEXT)
03500 (GO (NEXT))
03600 (: EXIT)
03700 (RETURN (CEVAL NOMORE (ACCESS)))
03800 (: RETURN)
03900 (RETURN POS)
04000 (: *METHOD)
04100 (METGO)
04200 (: *GENERATOR)
04300 (GENGO)
04400 (: *AU-REVOIR)
04500 (REGO)
04600 (: *BLOCK)
04700 (TBLOCK))
04800
04900 (DEFPROP NEXT
05000 (LAMBDA(L)
05100 (PROG NIL
05200 (SETQ L (/, POSSIBILITIES))
05300 (COND
05400 ((OR (ATOM L)
05500 (NOT (EQ (CAAR L) (QUOTE *POSSIBILITIES))))
05600 (CERR BAD POSSIBILITIES LIST)))
05700 (RETURN
05800 (PROG (P)
05900 (COND ((NULL (CDR L)) (RETURN (QUOTE EXIT))))
06000 (UNBLOCK (CDR L))
06100 TN (RPLACD L (CDDR L))
06200 (COND
06300 ((NULL (CDR L)) (RETURN (QUOTE EXIT)))
06400 ((EQ (SETQ P (CADR L)) (QUOTE *IGNORE))
06500 (GO TN))
06600 ((ATOM P) (CSET (QUOTE POS) P)
06700 (RETURN (QUOTE RETURN)))
06800 ((EQ (CAR P) (QUOTE *ITEM))
06900 (SETUP (CADDR P))
07000 (CSET (QUOTE POS) (CADR P))
07100 (RETURN (QUOTE RETURN)))
07200 ((EQ (CAR P) (QUOTE *NOTE))
07300 (SETUP (CADR P))
07400 (CSET (QUOTE POS) P)
07500 (RETURN (QUOTE RETURN)))
07600 ((MEMQ (CAR P)
07700 (QUOTE
07800 (*METHOD *GENERATOR
07900 *AU-REVOIR
08000 *BLOCK)))
08100 (RETURN (CAR P)))
08200 (T (CSET (QUOTE POS) P)
08300 (RETURN (QUOTE RETURN))))))))
08400 FEXPR)
08500
08600 (DEFPROP SETUP
08700 (LAMBDA(ALIST)
08800 (PROG NIL
08900 (SETQ TEM (ACCESS))
09000 (RETURN
09100 (MAPC (QUOTE
09200 (LAMBDA(PAIR)
09300 (CSET (CAR PAIR) (CADR PAIR) TEM)))
09400 ALIST))))
09500 EXPR)
09600
09700 (DEFPROP GENGO
09800 (LAMBDA NIL
09900 (PROG NIL
10000 (SETQ TEM (CDR (IVAL (QUOTE POSSIBILITIES) ALINK)))
10100 (SETQ BVARS (LIST (LIST (QUOTE NEXT) TEM)))
10200 (SETQ CLINK (FR (TAG (QUOTE TRY-NEXT))))
10300 (SETQ ALINK (ALINK CLINK))
10400 (SETQ TEM1 (CADAR TEM))
10500 (SETQ FRAME* NIL)
10600 (RPLACA TEM (LIST (QUOTE *BLOCK)))
10700 (RETURN
10800 (DISPATCH TEM1 (QUOTE POPJ) NIL (QUOTE *TOP)))))
10900 EXPR)
11000
11100 (DEFPROP GENGO GENGO CINT)
11200
11300 (DEFPROP METGO
11400 (LAMBDA NIL
11500 (PROG NIL
11600 (SETQ TEM (CDR (IVAL (QUOTE POSSIBILITIES) ALINK)))
11700 (SETQ TEM1 (CADAR TEM))
11800 (SETQ BVARS
11900 (NCONC (LIST (LIST (QUOTE NEXT) TEM)
12000 (LIST (QUOTE *BODY) (TEXT TEM1))
12100 (LIST
12200 (QUOTE *CALLPAT)
12300 (CADDDR (CDAR TEM)))
12400 (LIST
12500 (QUOTE *METHPAT)
12600 (PATTERN TEM1))
12700 (LIST
12800 (QUOTE *CALLALIST)
12900 (CADDDR (CAR TEM)))
13000 (LIST
13100 (QUOTE *METHALIST)
13200 (CADDAR TEM)))
13300 (CADDAR TEM)))
13400 (SETQ EXP (LIST TEM1 (CADDDR (CDAR TEM))))
13500 (SETQ FRAME* NIL)
13600 (SETQ CLINK (FR (TAG (QUOTE TRY-NEXT))))
13700 (SETQ ALINK (ALINK CLINK))
13800 (CLOSE)
13900 (RPLACA TEM (LIST (QUOTE *BLOCK)))
14000 (RETURN (QUOTE AUXB))))
14100 EXPR)
14200
14300 (DEFPROP METGO METGO CINT)
14400 (DEFPROP REGO
14500 (LAMBDA NIL
14600 (PROG NIL
14700 (SETQ TEM (CDR (IVAL (QUOTE POSSIBILITIES) ALINK)))
14800 (SETQ VAL (IVAL (QUOTE MESSAGE) ALINK))
14900 (SETQ FRAME* (CADAR TEM))
15000 (SETCONTROL (VFRAME (QUOTE NEXT) (CAR TEM))
15100 (TAG (QUOTE TRY-NEXT)))
15200 (CSET (QUOTE NEXT) TEM (CAR TEM))
15300 (RPLACA TEM (LIST (QUOTE *BLOCK)))
15400 (RETURN (RESTORE))))
15500 EXPR)
15600
15700 (DEFPROP REGO REGO CINT)
15800
15900 (CDEFUN TBLOCK
16000 NIL
16100 (NCONC (CADR POSSIBILITIES) (TAG (QUOTE TRY-NEXT)))
16200 (ALLOW NIL)
16300 (COND
16400 ((@ . READY)
16500 (CONTINUE
16600 (@ PROG2
16700 (ALLOW T)
16800 (CAR READY)
16900 (SETQ READY (CDR READY))))))
17000 (ALLOW T)
17100 (LISTEN (QUOTE ALL-BLOCKED-UP)))
17200
17300 (DEFPROP UNBLOCK
17400 (LAMBDA(L)
17500 (COND
17600 ((EQ (CAAR L) (QUOTE *BLOCK))
17700 (NCONC (GET (QUOTE READY) (QUOTE VALUE)) (CDAR L))
17800 (RPLACA L (QUOTE *IGNORE)))))
17900 EXPR)
18000
18100 (DEFPROP NOTE
18200 (LAMBDA N
18300 (COND
18400 ((= N 0) ((LAMBDA (P) (COND (P (ENTER P)))) (INSTANCE)) 0)
18500 (T
18600 (PROG (NEXT M)
18700 (SETQ M 0)
18800 (SETQ NEXT (CDR (VLOC (QUOTE NEXT))))
18900 LP (COND ((> (SETQ M (ADD1 M)) N) (RETURN N)))
19000 (RPLACD (CAR NEXT) (CONS (ARG M) (CDAR NEXT)))
19100 (RPLACA NEXT (CDAR NEXT))
19200 (GO LP)))))
19300 EXPR)
19400
19500 (CDEFUN ADIEU ("REST" L) (PROPOSE) (DISMISS (VFRAME (QUOTE NEXT))))
19600
19700 (CDEFUN AU-REVOIR
19800 ("REST" L)
19900 (PROPOSE)
20000 (ENTER (CONS (QUOTE *AU-REVOIR) (CDR (CONTROL))))
20100 (DISMISS (VFRAME (QUOTE NEXT))))
20200
20300 (DEFPROP ENTER
20400 (LAMBDA(X)
20500 (PROG NIL
20600 (SETQ TEM (CDR (VLOC (QUOTE NEXT))))
20700 (RPLACD (CAR TEM) (CONS X (CDAR TEM)))
20800 (RETURN (RPLACA TEM (CDAR TEM)))))
20900 EXPR)
21000
21050 (DECLARE(SPECIAL L))
21100 (DEFPROP PROPOSE
21200 (LAMBDA(L)
21300 (PROG NIL
21400 (SETQ L (CDR (VLOC (QUOTE NEXT))))
21500 (RETURN
21600 (MAPC (QUOTE
21700 (LAMBDA(X)
21800 (PROG NIL
21900 (RPLACD (CAR L) (CONS X (CDAR L)))
22000 (RETURN (RPLACA L (CDAR L))))))
22100 (/, L)))))
22200 FEXPR)
22250 (DECLARE(UNSPECIAL L))
22300
22400 (DEFPROP INSTANCE
22500 (LAMBDA(L)
22600 (PROG (NEXTF CALLA)
22700 (SETQ NEXTF (FR (VFRAME (QUOTE NEXT))))
22800 (SETQ CALLA (IVAL (QUOTE *CALLALIST) NEXTF))
22900 (SETQ L
23000 (MATCH (IVAL (QUOTE *CALLPAT) NEXTF)
23100 (IVAL (QUOTE *METHPAT) NEXTF)
23200 CALLA
23300 (IVAL (QUOTE *METHALIST) NEXTF)))
23400 (COND
23500 (L (RETURN (LIST (QUOTE *NOTE) (CPY (CAR L))))))))
23600 FEXPR)
23700 (DEFPROP CPY
23800 (LAMBDA(L)
23900 (MAPCAR (QUOTE (LAMBDA (X) (LIST (CAR X) (CADR X)))) L))
24000 EXPR)
24100
24200 (DEFPROP GET-POSSIBILITIES
24300 (LAMBDA NIL
24400 (IVAL (QUOTE POSSIBILITIES)
24500 (CLINK (FR (VFRAME (QUOTE NEXT))))))
24600 FEXPR)
24700
24800 (DEFPROP SET-POSSIBILITIES
24900 (LAMBDA(LIST)
25000 (CSET (QUOTE POSSIBILITIES)
25100 LIST
25200 (CONTROL (VFRAME (QUOTE NEXT)))))
25300 EXPR)
25400
25500 (CDEFUN GENERATE
25600 ((QUOTE FORM))
25700 "AUX"
25800 ((POSSIBILITIES
25900 (LIST (LIST (QUOTE *POSSIBILITIES) FORM)
26000 (LIST (QUOTE *GENERATOR) FORM))))
26100 (GENGO)
26200 (: TRY-NEXT)
26300 POSSIBILITIES)